1Attribute VB_Name = "BrowseDirectorysOnly"
2'*************************************************************************
3'
4'  Licensed to the Apache Software Foundation (ASF) under one
5'  or more contributor license agreements.  See the NOTICE file
6'  distributed with this work for additional information
7'  regarding copyright ownership.  The ASF licenses this file
8'  to you under the Apache License, Version 2.0 (the
9'  "License"); you may not use this file except in compliance
10'  with the License.  You may obtain a copy of the License at
11'
12'    http://www.apache.org/licenses/LICENSE-2.0
13'
14'  Unless required by applicable law or agreed to in writing,
15'  software distributed under the License is distributed on an
16'  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
17'  KIND, either express or implied.  See the License for the
18'  specific language governing permissions and limitations
19'  under the License.
20'
21'*************************************************************************
22
23' Modified as BIF_STATUSTEXT overflows for nested folders so is no longer
24' shown.
25
26'=====================================================================================
27' Browse for a Folder using SHBrowseForFolder API function with a callback
28' function BrowseCallbackProc.
29'
30' This Extends the functionality that was given in the
31' MSDN Knowledge Base article Q179497 "HOWTO: Select a Directory
32' Without the Common Dialog Control".
33'
34' After reading the MSDN knowledge base article Q179378 "HOWTO: Browse for
35' Folders from the Current Directory", I was able to figure out how to add
36' a callback function that sets the starting directory and displays the
37' currently selected path in the "Browse For Folder" dialog.
38'
39'
40' Stephen Fonnesbeck
41' steev@xmission.com
42' http://www.xmission.com/~steev
43' Feb 20, 2000
44'
45'=====================================================================================
46' Usage:
47'
48'    Dim folder As String
49'    folder = BrowseForFolder(Me, "Select A Directory", "C:\startdir\anywhere")
50'    If Len(folder) = 0 Then Exit Sub  'User Selected Cancel
51'
52'=====================================================================================
53
54Option Explicit
55
56Private Const BIF_STATUSTEXT = &H4&
57Private Const BIF_RETURNONLYFSDIRS = 1
58Private Const BIF_DONTGOBELOWDOMAIN = 2
59Private Const MAX_PATH = 260
60
61Private Const WM_USER = &H400
62Private Const BFFM_INITIALIZED = 1
63Private Const BFFM_SELCHANGED = 2
64Private Const BFFM_SETSELECTION = (WM_USER + 102)
65
66Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
67Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
68Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
69Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
70
71Private Type BrowseInfo
72  hWndOwner      As Long
73  pIDLRoot       As Long
74  pszDisplayName As Long
75  lpszTitle      As Long
76  ulFlags        As Long
77  lpfnCallback   As Long
78  lParam         As Long
79  iImage         As Long
80End Type
81
82Private m_CurrentDirectory As String   'The current directory
83'
84
85Public Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String
86  'Opens a Treeview control that displays the directories in a computer
87
88  Dim lpIDList As Long
89  Dim szTitle As String
90  Dim sBuffer As String
91  Dim tBrowseInfo As BrowseInfo
92  m_CurrentDirectory = StartDir & vbNullChar
93
94  szTitle = Title
95  With tBrowseInfo
96    .hWndOwner = owner.hWnd
97    .lpszTitle = lstrcat(szTitle, "")
98    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN '+ BIF_STATUSTEXT
99    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
100  End With
101
102  lpIDList = SHBrowseForFolder(tBrowseInfo)
103  If (lpIDList) Then
104    sBuffer = Space(MAX_PATH)
105    SHGetPathFromIDList lpIDList, sBuffer
106    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
107    BrowseForFolder = sBuffer
108  Else
109    BrowseForFolder = ""
110  End If
111
112End Function
113
114Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
115
116  Dim lpIDList As Long
117  Dim ret As Long
118  Dim sBuffer As String
119
120  On Error Resume Next  'Sugested by MS to prevent an error from
121                        'propagating back into the calling process.
122
123  Select Case uMsg
124
125    Case BFFM_INITIALIZED
126      Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
127
128  End Select
129
130  BrowseCallbackProc = 0
131
132End Function
133
134' This function allows you to assign a function pointer to a vaiable.
135Private Function GetAddressofFunction(add As Long) As Long
136  GetAddressofFunction = add
137End Function
138